MacHack 1997

home *** CD-ROM | disk | FTP | other *** search

/ MacHack 1997 / MacHack 1997.toast / Hacks / Hacks ’94 / [√] Distribution Restricted! / Christian Ruse / Fourier Paper + Apps / nih-image154_source.sea / V1.54 Source / File1.p < prev next >

Wrap

Text File | 1994-01-31 | 91KB | 3,237 lines

unit File1; {Routines used by Image for implementing File Menu commands.} interface uses QuickDraw, Palettes, PictUtil, PrintTraps, globals, Utilities, Graphics, file2, sound, Lut, Text; function CloseAWindow (WhichWindow: WindowPtr): integer; procedure DoClose; function OpenFile (fname: str255; vnum: integer): boolean; function OpenPict (fname: str255; vnum: integer; Reverting: boolean): boolean; procedure SaveFile; function DoOpen (FileName: str255; RefNum: integer): boolean; function ImportFile (FileName: str255; RefNum: integer): boolean; procedure RevertToSaved; procedure SaveAs (name: str255; RefNum: integer); procedure Export (name: str255; RefNum: integer); procedure FindWhatToPrint; procedure UpdateFileMenu; procedure SaveAsText (fname: str255; RefNum: integer); procedure SaveAll; procedure UpdateWindowsMenuItem (PicSize: LongInt; title: str255; PicNum: integer); procedure SaveScreen; function OpenPICS (name: str255; fRefNum: integer): boolean; procedure RescaleToEightBits; implementation var OpenAllFiles, UseExistingLUT, PICTReadErr, UpdateIcons: boolean; SaveRefNum: integer; TempStackInfo: StackInfoRec; PictSrcRect: rect; {$PUSH} {$D-} procedure LookForCluts (fname: str255; vnum: integer); var RefNum: integer; err: OSErr; ok1, ok2: boolean; begin if not UseExistingLUT then begin err := SetVol(nil, vnum); refNum := OpenResFile(fname); if RefNum <> -1 then begin ok1 := LoadCLUTResource(KlutzID); if not ok1 then ok2 := LoadCLUTResource(PixelPaintID); CloseResFile(refNum); end; end; end; function OpenImageHeader (f: integer; fname: str255; vnum: integer): boolean; var ByteCount: LongInt; err: OSErr; TempHdr: PicHeader; i, OldNExtra, p1x, p2x: integer; ok: boolean; hUnitsKind: UnitsType; begin ByteCount := HeaderSize; err := SetFPos(f, fsFromStart, info^.HeaderOffset); err := fsread(f, ByteCount, @TempHdr); if CheckIO(err) <> NoErr then begin OpenImageHeader := false; exit(OpenImageHeader); end; with info^, TempHdr do begin if PictureType <> TiffFile then begin nlines := hnlines; PixelsPerLine := hPixelsPerLine; end; if (hversion > 54) and not UseExistingLUT then begin OldNExtra := nExtraColors; nExtraColors := hnExtraColors; ExtraColors := hExtraColors; if (nExtraColors > 0) or (OldNExtra <> nExtraColors) then RedrawLUTWindow; end; if (hversion >= 42) and not UseExistingLUT then begin if hversion < 142 then begin LUTMode := hOldLUTMode; if (LutMode = OldAppleDefault) or (LutMode = OldSpectrum) then LutMode := ColorLut; end else begin LUTMode := hLUTMode; if LutMode = Pseudocolor then begin if ((hnColors > 32) and (hTable = CustomTable)) or (hTable > spectrum) then LutMode := ColorLut; end; end; case LUTMode of PseudoColor: if hversion < 142 then begin nColors := hOldnColors; for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; ColorEnd := 255 - hOldColorStart; ColorStart := ColorEnd - nColors * hColorWidth + 1; if ColorStart < 0 then ColorStart := 0; InvertPalette; FillColor1 := BlackRGB; FillColor2 := BlackRGB; ColorTable := CustomTable; UpdateLUT; end else begin {V1.42 or later} if (hTable <> CustomTable) and (hTable <= spectrum) then begin SwitchColorTables(GetColorTableItem(hTable), false); if hInvertedTable then InvertPalette; end else begin nColors := hnColors; ColorTable := CustomTable; if nColors <= 32 then for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; end; ColorStart := hColorStart; ColorEnd := hColorEnd; FillColor1 := hFill1; FillColor2 := hFill2; UpdateLUT; UpdateMap; end; {v1.42 or later} GrayScale: ResetGrayMap; ColorLut, CustomGrayscale: if PictureType <> PictFile then begin if ColorMapOffset > 0 then GetTiffColorMap(f) else LookForCluts(fname, vnum); end; otherwise end; {case} if hLutMode = CustomGrayscale then LutMode := CustomGrayscale; end;{if} if (hversion >= 65) and ((ForegroundIndex <> hForegroundIndex) or (BackgroundIndex <> hBackgroundIndex)) then begin SetForegroundColor(hForegroundIndex); SetBackgroundColor(hBackgroundIndex); end; if (hversion > 88) and (LUTMode = GrayScale) and not UseExistingLUT then begin if hversion < 138 then begin p1x := 255 - hp2x; p2x := 255 - hp1x; end else begin p1x := hp1x; p2x := hp2x end; nColors := 256; ColorStart := p1x; ColorEnd := p2x; UpdateLUT; end; if hversion > 106 then begin xSpatialScale := hXSpatialScale; ySpatialScale := xSpatialScale; PixelAspectRatio := 1.0; SpatiallyCalibrated := xSpatialScale <> 0.0; end; if hversion > 140 then begin PixelAspectRatio := hPixelAspectRatio; ySpatialScale := xSpatialScale / PixelAspectRatio; end; if hversion > 153 then xUnit := hXUnit else begin hUnitsKind := UnitsType(hUnitsID - 5); GetXUnits(hUnitsKind); end; if ((hnCoefficients > 0) and (hfit < UncalibratedOD)) or (hfit = UncalibratedOD) then begin if (hfit = SpareFit1) or (hfit = SpareFit2) then begin DensityCalibrated := false; DrawLabels('', '', ''); end else begin fit := hfit; if hfit <> UncalibratedOD then begin nCoefficients := hnCoefficients; Coefficient := hCoeff; end; UnitOfMeasure := hUM; DensityCalibrated := true; if hversion >= 144 then ZeroClip := hZeroClip else ZeroClip := false; GenerateValues; end; end else begin DensityCalibrated := false; DrawLabels('', '', ''); end; BinaryPic := hBinaryPic; if hSliceEnd > 1 then begin SliceStart := hSliceStart; SliceEnd := hSliceEnd; if SliceEnd > 254 then SliceEnd := 254; end; if hNSlices > 1 then begin with TempStackInfo do begin nSlices := hNSlices; if nSlices > MaxSlices then nSlices := MaxSlices; CurrentSlice := hCurrentSlice; if (hCurrentSlice < 1) or (hCurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := hSliceSpacing; LoopTime := hLoopTime; end; end; iVersion := hVersion; OpenImageHeader := true end; end; function OpenHeader (f: integer; fname: str255; vnum: integer; var NextTiffIFD: LongInt): boolean; var ByteCount, FileSize, DirOffset, MaxImages: LongInt; hdr: packed array[1..512] of byte; err: OSErr; TempHdr: PicHeader; TiffInfo: TiffInfoRec; begin with info^ do begin if (WhatToOpen = OpenUnknown) or (WhatToOpen = OpenImported) then begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @hdr); if ((hdr[1] = 73) and (hdr[2] = 73)) or ((hdr[1] = 77) and (hdr[2] = 77)) then WhatToOpen := OpenTIFF else if WhatToOpen = OpenUnknown then WhatToOpen := OpenImage else WhatToOpen := OpenMCID; end; StackInfo := nil; with TempStackInfo do begin nSlices := 0; CurrentSlice := 1; SliceSpacing := 0.0; LoopTime := 0.0; end; NextTiffIFD := 0; iVersion := 0; case WhatToOpen of OpenImage: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then begin HeaderOffset := 0; PictureType := normal end else begin HeaderOffset := -1; BlockMove(@TempHdr, @hdr, 8); nlines := hdr[1] + hdr[2] * 256; PixelsPerLine := hdr[3] + hdr[4] * 256; PictureType := PDP11; end; ImageDataOffset := 512; end; OpenMCID: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); PixelsPerLine := hdr[1] + hdr[2] * 256 + 1; if PixelsPerLine > MaxLine then begin beep; PixelsPerLine := MaxLine; end; nlines := hdr[3] + hdr[4] * 256 + 1; PictureType := imported; LUTMode := grayscale; HeaderOffset := -1; ImageDataOffset := 4; end; OpenCustom: begin err := GetEof(f, FileSize); if macro then begin if (ImportCustomOffset + LongInt(ImportCustomWidth) * ImportCustomHeight) > FileSize then begin macro := false; OpenHeader := false; exit(OpenHeader) end; end; PixelsPerLine := ImportCustomWidth; nlines := ImportCustomHeight; PictureType := imported; HeaderOffset := -1; ImageDataOffset := ImportCustomOffset; if ImportCustomSlices > 1 then with TempStackInfo do begin nSlices := ImportCustomSlices; MaxImages := (FileSize - ImportCustomOffset) div (LongInt(ImportCustomWidth) * ImportCustomHeight); if nSlices > MaxImages then nSlices := MaxImages; if nSlices < 2 then nSlices := 0; end; end; OpenPICT2: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then HeaderOffset := 0 else HeaderOffset := -1; PictureType := PictFile; if not UseExistingLUT then LutMode := ColorLut; ImageDataOffset := 512; end; OpenTIFF: begin if not OpenTiffHeader(f, DirOffset) then begin OpenHeader := false; exit(OpenHeader) end; if not OpenTiffDirectory(f, DirOffset, TiffInfo) then begin OpenHeader := false; exit(OpenHeader) end; with TiffInfo do begin PictureType := TiffFile; PixelsPerLine := width; nlines := height; if BitsPerPixel = 4 then PictureType := FourBitTiff; ImageDataOffset := OffsetToData; if ZeroIsBlack and (PictureType <> FourBitTIFF) then PictureType := InvertedTiff; if resolution > 0.0 then begin case ResUnits of tNoUnits: xUnit := 'pixel'; tCentimeters: xUnit := 'cm'; tInches: xUnit := 'inch'; end; xSpatialScale := resolution; ySpatialScale := resolution; PixelAspectRatio := 1.0; if xUnit <> 'pixel' then SpatiallyCalibrated := true; end; ColorMapOffset := OffsetToColorMap; HeaderOffset := OffsetToImageHeader; NextTiffIFD := NextIFD; end; if not UseExistingLUT then LutMode := Grayscale; end; end; {case} if HeaderOffset <> -1 then begin if not OpenImageHeader(f, fname, vnum) then begin OpenHeader := false; exit(OpenHeader) end end else if (ColorMapOffset > 0) and not UseExistingLUT then GetTiffColorMap(f); end; {with} OpenHeader := true; end; function SaveHeader (f, slines, sPixelsPerLine, vnum: integer; fname: str255; SavingSelection, SavingTIFF: boolean): OSErr; var TempHdr: PicHeader; DummyHdr: array[1..128] of LongInt; i: integer; ByteCount: LongInt; position: LongInt; err: OSErr; str: str255; UnitsKind: UnitsType; UnitsPerCM: double; begin with TempHdr, info^ do begin for i := 1 to 128 do DummyHdr[i] := 0; BlockMove(@DummyHdr, @TempHdr, HeaderSize); FileID := FileID8; hnlines := nlines; hPixelsPerLine := PixelsPerLine; hversion := version; hLUTMode := LUTMode; hOldLutMode := LutMode; hnColors := ncolors; hOldnColors := 0; if LutMode = Pseudocolor then begin hOldLutMode := ColorLut; if (ColorTable = CustomTable) and (ncolors <= 32) then for i := 0 to nColors - 1 do begin hr[i] := RedLUT[i]; hg[i] := GreenLUT[i]; hb[i] := BlueLUT[i]; end; end; hColorStart := ColorStart; hColorEnd := ColorEnd; hFill1 := FillColor1; hFill2 := FillColor2; hTable := ColorTable; hInvertedTable := InvertedColorTable; hOldColorStart := 255 - ColorEnd; if nColors > 0 then hColorWidth := (ColorEnd - ColorStart) div nColors else hColorWidth := 1; hnExtraColors := nExtraColors; hExtraColors := ExtraColors; hForegroundIndex := ForegroundIndex; hBackgroundIndex := BackgroundIndex; hXSpatialScale := xSpatialScale; hScaleMagnification := 1.0; hPixelAspectRatio := PixelAspectRatio; hUnitsID := 14; {Pixels. For backward compatibility only since hUnits no longer used.} if SpatiallyCalibrated then begin GetUnitsKind(UnitsKind, UnitsPerCM); hUnitsID := ord(UnitsKind) + 5; if hUnitsID > 14 then hUnitsID := 14; end; FindPoints(hp1x, hp1y, hp2x, hp2y); if not DensityCalibrated then hnCoefficients := 0 else hnCoefficients := nCoefficients; hfit := fit; hCoeff := Coefficient; hZeroClip := ZeroClip; hUM := UnitOfMeasure; hBinaryPic := BinaryPic; hSliceStart := SliceStart; hSliceEnd := SliceEnd; if StackInfo <> nil then with StackInfo^ do begin hNSlices := nSlices; hSliceSpacing := SliceSpacing; hCurrentSlice := CurrentSlice; hLoopTime := LoopTime; end else begin hNSlices := 0; hSliceSpacing := 0.0; hCurrentSlice := 0; hLoopTime := 0.0; end; hXUnit := xUnit; ByteCount := SizeOf(TempHdr); if ByteCount <> HeaderSize then begin NumToString(ByteCount, str); PutMessage('Internal error check: header size is incorrect.'); ExitToShell; end; if SavingSelection then begin hnlines := slines; hPixelsPerLine := sPixelsPerLine; end; err := fswrite(f, ByteCount, @TempHdr); SaveHeader := CheckIO(err); end; {with} end; procedure PackLines; {For odd width images, removes the extra bytes at the end of each line required to make RowBytes even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + BytesPerRow); DstPtr := ptr(ord4(PicBaseAddr) + PixelsPerLine); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) + BytesPerRow); DstPtr := ptr(ord4(DstPtr) + PixelsPerLine); end; end; end; procedure UnpackLines; {For odd width images, adds an extra byte to each line so RowBytes is even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * PixelsPerLine); DstPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * BytesPerRow); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine); DstPtr := ptr(ord4(DstPtr) - BytesPerRow); end; end; end; function WriteSlices (f: integer): integer; var ByteCount, SelectionSize: LongInt; i, err, SaveCS: integer; begin with info^, Info^.StackInfo^ do begin SaveCS := CurrentSlice; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; ByteCount := ImageSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if err <> 0 then leave; end; CurrentSlice := SaveCS; SelectSlice(CurrentSlice); UpdateTitleBar; WriteSlices := err; end; end; procedure WriteSelection (f: integer; sLines, sPixelsPerLine: LongInt); {Contributed by Edward J. Huff(huff@mcclb0.med.nyu.edu).} var size, offset, ByteCount, BytesDone: LongInt; src, dst: ptr; err: OSErr; begin if sPixelsPerLine > UndoBufSize then exit(WriteSelection); size := sLines * sPixelsPerLine; with info^, info^.RoiRect do begin offset := LongInt(top) * BytesPerRow + left; src := ptr(ord4(PicBaseAddr) + offset); BytesDone := 0; while BytesDone < size do begin ByteCount := 0; dst := UndoBuf; while ((ByteCount + sPixelsPerLine) < UndoBufSize) and (BytesDone < size) do begin BlockMove(src, dst, sPixelsPerLine); src := ptr(ord4(src) + BytesPerRow); dst := ptr(ord4(dst) + sPixelsPerLine); ByteCount := ByteCount + sPixelsPerLine; BytesDone := BytesDone + sPixelsPerLine; end; err := fswrite(f, ByteCount, UndoBuf); end; SetupUndo; {Needed for drawing roi outline} end end; function SaveTiffFile (fname: str255; vnum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var f, err, i, width, height: integer; HdrSize, ByteCount, ctabSize, StackTiffDirSize, ImageDataSize: LongInt; TheInfo: FInfo; MCIDHeader: packed array[1..4] of byte; SaveColorMap: boolean; begin SaveTiffFile := false; ShowWatch; err := fsopen(fname, vNum, f); if CheckIO(err) <> 0 then exit(SaveTiffFile); with Info^ do begin SaveColorMap := (LutMode <> Grayscale) and (SaveAsWhat <> asRawData); if SaveAsWhat = SaveAsMCID then begin if SavingSelection then begin width := sPixelsPerLine; height := slines; end else begin width := PixelsPerLine; height := nLines; end; MCIDHeader[1] := (width - 1) mod 256; MCIDHeader[2] := (width - 1) div 256; MCIDHeader[3] := (height - 1) mod 256; MCIDHeader[4] := (height - 1) div 256; ByteCount := 4; err := fswrite(f, ByteCount, @MCIDHeader); end; HeaderOffset := TiffDirSize; ImageDataOffset := TiffDirSize + HeaderSize; if SaveColorMap then ctabSize := SizeOf(TiffColorMapType) else ctabSize := 0; StackTiffDirSize := 0; if SavingSelection then ImageDataSize := LongInt(slines) * sPixelsPerLine else if StackInfo <> nil then begin ImageDataSize := ImageSize * StackInfo^.nSlices; StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1) end else ImageDataSize := ImageSize; if (SaveAsWhat <> asRawData) and (SaveAsWhat <> SaveAsMCID) then begin if SaveTiffDir(f, slines, sPixelsPerLine, SavingSelection, ctabSize, ImageDataSize) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; err := SetFPos(f, FSFromStart, TiffDirSize); if SaveHeader(f, slines, sPixelsPerLine, vnum, fname, SavingSelection, true) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; end; if SaveAsWhat = SaveAsMCID then KillRoi; if SavingSelection then WriteSelection(f, sLines, sPixelsPerLine) else if StackInfo <> nil then err := WriteSlices(f) else begin ByteCount := ImageDataSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; end; if SaveAsWhat = SaveAsMCID then InvertPic; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; if SaveAsWhat = asRawData then HdrSize := 0 else if SaveAsWhat = SaveAsMCID then begin HdrSize := 4; SaveAsWhat := asRawData; end else HdrSize := HeaderSize + TiffDirSize; if SaveColorMap then SaveTiffColorMap(f, ImageDataSize); if StackTiffDirSize > 0 then err := WriteExtraTiffIFDs(f, ImageDataSize, cTabSize); err := SetEOF(f, HdrSize + ImageDataSize + ctabSize + StackTiffDirSize); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if SaveAsWhat = asRawData then begin TheInfo.fdType := 'RawD'; err := SetFInfo(fname, vnum, TheInfo); end else if TheInfo.fdType <> 'TIFF' then begin TheInfo.fdType := 'TIFF'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vNum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> ScionType) and (SaveAsWhat <> asRawData) then begin PictureType := TiffFile; title := fname; vref := vnum; UpdateTitleBar; if StackInfo = nil then revertable := true; end; end; if SaveAsWhat <> asRawData then Changes := false; end; {with} SaveTiffFile := true; end; procedure UpdateWindowsMenuItem (PicSize: LongInt; title: str255; PicNum: integer); var str: str255; begin NumToString((PicSize + 511) div 1024, str); str := concat(title, ' ', str, 'K'); SetItem(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows, str); end; procedure SaveAsTIFF (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean); var err: integer; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') and (fdType <> 'RawD') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsTIFF) end; replacing := true; end; FNFerr: begin if SaveAsWhat = asRawData then err := create(fname, RefNum, 'Imag', 'RawD') else err := create(fname, RefNum, 'Imag', 'TIFF'); if CheckIO(err) <> 0 then exit(SaveAsTIFF); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTIFF); end; if replacing then if not RoomForFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection) then exit(SaveAsTIFF); ok := SaveTiffFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection); if ok then with info^ do if StackInfo <> nil then UpdateWindowsMenuItem(PixMapSize * StackInfo^.nSlices, title, PicNum) else UpdateWindowsMenuItem(PixMapSize, title, PicNum); with info^ do if SavingSelection and Replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> ScionType) then PictureType := Leftover; end; function SavePICTFile (fname: str255; vnum: integer; SavingSelection, NewFile: boolean): boolean; var f, err, i, v: integer; ByteCount, PICTSize: LongInt; PicH: PicHandle; fRect, frect2: rect; tPort: GrafPtr; TheInfo: FInfo; SaveInfoRec: PicInfo; HeaderSaved: boolean; procedure Abort; begin err := fsclose(f); if NewFile then err := FSDelete(fname, vnum); DisposHandle(handle(PicH)); exit(SavePICTFile) end; begin with info^ do begin if OpPending then KillRoi; SavePICTFile := false; ShowWatch; GetPort(tPort); if SavingSelection then fRect := RoiRect else SetRect(fRect, 0, 0, PixelsPerLine, nlines); with frect do SetRect(frect2, 0, 0, right - left, bottom - top); with osPort^ do begin SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin {Work around for Palette Manager bug in Systems before 6.0.5.} RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; ClipRect(PicRect); LoadLUT(cTable); {Restore look-up table in case it has changed.} PicH := OpenPicture(fRect2); hlock(handle(PortPixMap)); CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^, frect, frect2, SrcCopy, nil); hunlock(handle(PortPixMap)); ClosePicture; pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; SetPort(tPort); PICTSize := GetHandleSize(handle(PicH)); if PICTSize <= 10 then begin PutMessage('Sorry, but there is not enough memory available to save this PICT file. Try closing some windows, or save as TIFF.'); if NewFile then err := FSDelete(fname, vnum); DisposHandle(handle(PicH)); exit(SavePICTFile) end; err := fsopen(fname, vnum, f); err := SetFPos(f, FSFromStart, 0); SaveInfoRec := Info^; if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then begin nColors := 256; ColorStart := 0; ColorEnd := 255; LUTMode := Grayscale; IdentityFunction := true; end; HeaderSaved := SaveHeader(f, 0, 0, vnum, fname, SavingSelection, false) = 0; Info^ := SaveInfoRec; if not HeaderSaved then abort; err := fswrite(f, PICTSize, pointer(PicH^)); if CheckIO(err) <> 0 then abort; DisposHandle(handle(PicH)); ByteCount := PICTSize + HeaderSize; err := SetEOF(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if TheInfo.fdType <> 'PICT' then begin TheInfo.fdType := 'PICT'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vnum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> ScionType) and (PictureType <> NullPicture) then begin PictureType := PictFile; title := fname; UpdateTitleBar; vref := vnum; revertable := true; end; Changes := false; end; end; {with} SavePICTFile := true; end; procedure SaveAsPICT (fname: str255; RefNum: integer; SavingSelection: boolean); var f, err, i: integer; where: Point; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') then begin TypeMismatch(fname); exit(SaveAsPICT) end; replacing := true; end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'PICT'); if CheckIO(err) <> 0 then exit(SaveAsPICT); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsPICT); end; ok := SavePICTFile(fname, RefNum, SavingSelection, not Replacing); if ok then with info^ do UpdateWindowsMenuItem(PixMapSize, title, PicNum); with info^ do if SavingSelection and replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> ScionType) then PictureType := Leftover; end; procedure SaveSelection (fname: str255; RefNum: integer; SaveAsSameType: boolean); var slines, spixelsPerLine: integer; begin if NoSelection or NotRectangular or NotInBounds then exit(SaveSelection); if OpPending then KillRoi; with info^ do begin with RoiRect do begin sPixelsPerLine := right - left; if odd(sPixelsPerLine) and (left + sPixelsPerLine < PicRect.right) and (SaveAsWhat <> asRawData) then sPixelsPerLine := sPixelsPerLine + 1; slines := bottom - top; end; if (PictureType = PictFile) and SaveAsSameType and (SaveAsWhat <> asRawData) then SaveAsPICT(fname, RefNum, true) else SaveAsTIFF(fname, RefNum, sLines, sPixelsPerLine, true); end; end; procedure SaveAsText (fname: str255; RefNum: integer); var err, f: integer; TheInfo: FInfo; ByteCount: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(SaveAsText) end; FNFerr: begin err := create(fname, RefNum, TextCreator, 'TEXT'); if CheckIO(err) <> 0 then exit(SaveAsText); end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTExt) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveAsText); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); if CheckIO(err) <> 0 then exit(SaveAsText); err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, RefNum); if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; end; procedure SaveAsPICS (fname: str255; fRefNum: integer); const rErr = 'Error Saving PICS file.'; var err: OSErr; TheInfo: FInfo; replacing: boolean; rRefNum, i, SaveCS: integer; frect: rect; PicH: array[1..MaxSlices] of PicHandle; MinFreeRequired: LongInt; begin with info^, Info^.StackInfo^ do begin if StackInfo = nil then begin PutMessage('Only Stacks can be saved in PICS format.'); SaveAsWhat := asTiff; exit(SaveAsPICS); end; if ImageSize > MinFree then MinFreeRequired := ImageSize else MinFreeRequired := MinFree; if MaxBlock < MinFreeRequired then begin PutMessage('Not enough memory available to save in PICS format.'); exit(SaveAsPICS); end; err := GetFInfo(fname, fRefNum, TheInfo); if err = NoErr then with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsPICS) end; err := FSDelete(fname, fRefNum); end; ShowWatch; err := SetVol(nil, fRefNum); CreateResFile(fname); if ResError <> NoErr then exit(SaveAsPICS); rRefNum := OpenResFile(fname); SaveCS := CurrentSlice; SetPort(GrafPtr(osPort)); with PicRect do SetRect(frect, 0, 0, right - left, bottom - top); ClipRect(frect); LoadLUT(ctable); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; PicH[i] := OpenPicture(frect); with osPort^ do begin hlock(handle(portPixMap)); CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, PicRect, frect, SrcCopy, nil); hunlock(handle(portPixMap)); end; ClosePicture; if (PicH[i] = nil) or ((PicH[i] <> nil) and (GetHandleSize(handle(PicH[i])) <= 10)) then begin PutMessage(rErr); leave; end; AddResource(handle(PicH[i]), 'PICT', i - 1 + 128, ''); if ResError <> NoErr then begin PutMessage(rErr); leave; end; WriteResource(handle(PicH[i])); ReleaseResource(handle(PicH[i])); if ResError <> NoErr then begin PutMessage(rErr); leave; end; end; {for} CurrentSlice := SaveCS; SelectSlice(CurrentSlice); title := fname; PictureType := PicsFile; UpdateTitleBar; CloseResFile(rRefNum); if ResError <> NoErr then PutMessage(rErr); err := GetFInfo(fname, fRefNum, TheInfo); TheInfo.fdType := 'PICS'; TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, fRefNum, TheInfo); err := FlushVol(nil, fRefNum); UpdateWindowsMenuItem(PixMapSize, title, PicNum); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; {with} end; function SuggestedName: str255; var name: str255; begin case SaveAsWhat of asTiff, asPict, asMacPaint, asRawData, asPICS: begin name := info^.title; if name = 'Camera' then name := 'Untitled'; SuggestedName := name; end; AsPalette: SuggestedName := 'Palette'; AsOutline: SuggestedName := 'Outline'; end; end; function SaveAsHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; TiffID = 9; OutlineID = 14; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDialogItem(theDialog, TiffID + ord(SaveAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedName; if (item >= TiffID) and (item <= OutlineID) then begin SaveAsWhat := SaveAsWhatType(item - TiffID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedName); SelIText(theDialog, EditTextID, 0, 32767); end; for i := TiffID to OutlineID do SetDialogItem(theDialog, i, 0); SetDialogItem(theDialog, item, 1); end; SaveAsHook := item; end; procedure SaveAs (name: str255; RefNum: integer); const CustomDialogID = 60; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; begin with info^ do begin if SaveAllState = SaveAllStage2 then begin name := title; RefNum := SaveRefNum; if SaveAsWhat = AsPalette then SaveAsWhat := AsTiff; end else if (name = '') or (RefNum = 0) then begin where.v := 50; where.h := 50; if (StackInfo = nil) and (SaveAsWhat = asPICS) then SaveAsWhat := asTIFF; if (StackInfo <> nil) and ((SaveAsWhat = asPICT) or (SaveAsWhat = asMacPaint)) then SaveAsWhat := asTIFF; if name = '' then name := SuggestedName; SFPPutFile(Where, 'Save as?', name, @SaveAsHook, reply, CustomDialogID, nil); if not reply.good then begin SaveAllState := NoSaveAll; macro := false; exit(SaveAs); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if StackInfo <> nil then begin if SaveAsWhat <> asOutline then KillRoi; SaveAllState := NoSaveAll; if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette) or (SaveAsWhat = asOutline)) then begin PutMessage('Stacks can only be saved in TIFF or PICS format.'); SaveAsWhat := asTIFF; exit(SaveAs); end; end; isSelection := RoiShowing and (RoiType = RectRoi); if SaveAllState = SaveAllStage1 then begin SaveRefNum := RefNum; SaveAllState := SaveAllStage2; end; case SaveAsWhat of asTiff, asRawData: if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); asPict: if isSelection then SaveAsPICT(name, RefNum, true) else SaveAsPICT(name, RefNum, false); asMacPaint: SaveAsMacPaint(name, RefNum); asPICS: SaveAsPICS(name, RefNum); AsPalette: SaveColorTable(name, RefNum); AsOutline: SaveOutline(name, RefNum); end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; procedure SaveFile; var fname: str255; size: LongInt; ok: boolean; begin if CurrentWindow = ResultsKind then begin Export('', 0); exit(SaveFile); end; if CurrentWindow = TextKind then begin SaveText; exit(SaveFile); end; if OpPending then KillRoi; with Info^ do begin fname := title; size := 0; if PictureType = TiffFile then ok := SaveTiffFile(fname, vref, 0, 0, false) else if PictureType = PictFile then ok := SavePICTFile(fname, vref, false, false) else SaveAs('', 0); end; end; function SaveChanges: integer; const yesID = 1; noID = 2; cancelID = 3; var id: integer; reply: SFReply; begin id := 0; if info^.changes then with info^ do begin if CommandPeriod or MakingStack or (macro and ((MacroCommand = DisposeC) or (MacroCommand = DisposeAllC))) then begin SaveChanges := ok; exit(SaveChanges); end; ParamText(title, '', '', ''); InitCursor; id := alert(600, nil); if id = yesID then begin SaveFile; InitCursor; end; {if yes} end; {if changes} if (id = cancelID) or ((id = yesID) and (info^.changes)) then SaveChanges := cancel else SaveChanges := ok; end; function CloseAWindow (WhichWindow: WindowPtr): integer; var i, kind, n: integer; TempInfo: InfoPtr; TempTextInfo: TextInfoPtr; SizeStr, str: str255; wp: ^WindowPtr; pcrect: rect; begin if WhichWindow = nil then exit(CloseAWindow); kind := WindowPeek(WhichWindow)^.WindowKind; CloseAWindow := ok; if WhichWindow = VideoControl then begin DisposDialog(VideoControl); VideoControl := nil; exit(CloseAWindow); end; case kind of PicKind: begin Info := pointer(WindowPeek(WhichWindow)^.RefCon); with Info^ do begin if PicNum = 0 then begin beep; exit(CloseAWindow); end; if SaveChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DelMenuItem(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows); for i := PicNum to nPics - 1 do begin PicWindow[i] := PicWindow[i + 1]; TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); TempInfo^.PicNum := i end; if PictureType = BlankField then BlankFieldInfo := nil; if StackInfo <> nil then begin with StackInfo^ do for i := 1 to nSlices do DisposHandle(PicBaseH[i]); DisposPtr(pointer(StackInfo)); end else begin if not MakingStack then DisposHandle(PicBaseHandle); end; DisposeWindow(WhichWindow); CloseCPort(osPort); DisposPtr(ptr(osPort)); DisposeRgn(roiRgn); nPics := nPics - 1; OpPending := false; isInsertionPoint := false; DisposPtr(pointer(Info)); Info := NoInfo; if (nPics = 0) and (not finished) then with info^ do begin LoadLUT(info^.cTable); if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then DrawMap; end; PicLeft := PicLeftBase; PicTop := PicTopBase; end; end; {PicKind} HistoKind: begin DisposeWindow(HistoWindow); HistoWindow := nil; ContinuousHistogram := false; end; ProfilePlotKind, CalibrationPlotKind: begin DisposeWindow(PlotWindow); PlotWindow := nil; KillPicture(PlotPICT); PlotPICT := nil; end; ResultsKind: begin DisposeWindow(ResultsWindow); ResultsWindow := nil; TEDispose(ListTE); end; TextKind: begin TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon); if TextInfo <> nil then with TextInfo^ do begin if SaveTextChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DisposeWindow(TextWindowPtr); DelMenuItem(WindowsMenuH, WindowsMenuItems - 1 + WindowNum); TEDispose(TextTE); DisposePtr(ptr(TextInfo)); TextInfo := nil; for i := WindowNum to nTextWindows - 1 do begin TextWindow[i] := TextWindow[i + 1]; TempTextInfo := pointer(WindowPeek(TextWindow[i])^.RefCon); TempTextInfo^.WindowNum := i end; nTextWindows := nTextWindows - 1; end; end; PasteControlKind: begin GetWindowRect(PasteControl, pcrect); with pcrect do begin PasteControlLeft := left; PasteControlTop := top; end; DisposeWindow(PasteControl); PasteControl := nil; wp := pointer(GhostWindow); wp^ := nil; end; otherwise ; end; {case} end; procedure DoClose; var ignore: integer; fwptr: WindowPtr; kind: integer; begin fwptr := FrontWindow; if fwptr <> nil then begin if fwptr = VideoControl then begin DisposDialog(VideoControl); VideoControl := nil; exit(DoClose); end; kind := WindowPeek(fwptr)^.WindowKind; if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) or (Kind = TextKind) then ignore := CloseAWindow(fwptr); end; end; procedure Read4BitTIFF (f: integer); var vloc, hloc, i: integer; ByteCount, count: LongInt; err: OSErr; UnpackedLine, PackedLine: LineType; begin with info^ do begin if PixelsPerLine > MaxLine then exit(Read4BitTIFF); ByteCount := (PixelsPerLine + 1) div 2; for vloc := 0 to nLines - 1 do begin err := FSRead(f, ByteCount, @PackedLine); i := 0; for hloc := 0 to PixelsPerLine - 1 do if odd(hloc) then begin UnpackedLine[hloc] := bsl(band(PackedLine[i], $F), 4); i := i + 1; end else UnpackedLine[hloc] := band(PackedLine[i], $F0); PutLine(0, vloc, PixelsPerLine, UnpackedLine); end; end; {with} end; procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTable); var i, err, SaveCS: integer; h: handle; DataSize: LongInt; begin ShowMessage(CmdPeriodToStop); with info^ do begin StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(ReadStackSlices); end; with info^, info^.StackInfo^ do begin nSlices := nExtraImages + 1; CurrentSlice := TempStackInfo.CurrentSlice; if (CurrentSlice < 1) or (CurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := TempStackInfo.SliceSpacing; LoopTime := TempStackInfo.LoopTime; SaveCS := CurrentSlice; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := NewHandle(PixMapSize); if h = nil then begin nSlices := i - 1; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; err := SetFPos(f, fsFromStart, table[i - 1].offset); err := fsread(f, DataSize, h^); if odd(PixelsPerLine) then UnpackLines; if (PictureType = InvertedTIFF) or ((PictureType = Imported) and ImportInvert) then InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutMessage(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.')); end; CurrentSlice := SaveCS; if CurrentSlice > nSlices then CurrentSlice := 1; SelectSlice(CurrentSlice); UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); end; end; procedure OpenStack (f: integer); var table: TiffIFDTable; i, nExtraImages: integer; where: LongInt; begin nExtraImages := TempStackInfo.nSlices - 1; with info^ do begin where := ImageDataOffset; for i := 1 to nExtraImages do with table[i] do begin iWidth := PixelsPerLine; iHeight := nLines; where := where + ImageSize; Offset := where; invert := false; end; ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenExtraTiffImages (f: integer; NextTiffIFD: LongInt); var table: TiffIFDTable; TiffInfo: TiffInfoRec; i, nExtraImages: integer; AllSameSize: boolean; begin nExtraImages := 0; repeat if not OpenTiffDirectory(f, NextTiffIFD, TiffInfo) then exit(OpenExtraTiffImages); nExtraImages := nExtraImages + 1; with TiffInfo, table[nExtraImages] do begin iWidth := width; iHeight := height; Offset := OffsetToData; invert := ZeroIsBlack; NextTiffIFD := NextIFD; end; until (NextTiffIFD = 0) or (nExtraImages = MaxSlices); AllSameSize := true; with info^ do begin for i := 1 to nExtraImages do AllSameSize := AllSameSize and (PixelsPerLine = table[i].iWidth) and (nLines = table[i].iHeight); if AllSameSize and not odd(PixelsPerLine) then ReadStackSlices(f, nExtraImages, table); end; end; function OpenFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; p: ptr; iptr: ptr; SaveInfo: InfoPtr; begin OpenFile := false; ShowWatch; err := fsopen(fname, vNum, f); SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(f); exit(OpenFile) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); with Info^ do begin ColorMapOffset := 0; if not OpenHeader(f, fname, vnum, NextTiffIFD) then begin DisposPtr(iptr); err := fsclose(f); Info := SaveInfo; exit(OpenFile) end; PicBaseAddr := GetImageMemory(SaveInfo, PicBaseHandle); if PicBaseAddr = nil then begin err := fsclose(f); exit(OpenFile) end; MakeNewWindow(fname); err := SetFPos(f, fsFromStart, ImageDataOffset); if PictureType = FourBitTIFF then Read4BitTIFF(f) else begin DataSize := LongInt(nlines) * PixelsPerLine; err := fsread(f, DataSize, PicBaseAddr); if CheckIO(err) <> NoErr then begin err := fsclose(f); exit(OpenFile) end; end; if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then UnpackLines; if (PictureType = pdp11) or (PictureType = InvertedTIFF) or ((PictureType = Imported) and (ImportInvert or (WhatToImport = ImportMCID))) then InvertPic; if PictureType = FourBitTIFF then PictureType := imported; vref := vnum; if PixMapSize > UndoBufSize then PutWarning; revertable := true; end; {with} if TempStackInfo.nSlices > 0 then OpenStack(f) else if NextTiffIFD > 0 then OpenExtraTiffImages(f, NextTiffIFD); err := fsclose(f); OpenFile := true; end; procedure ScaleToEightBits (f: integer); type PixelLUTType = packed array[0..65535] of Unsignedbyte; PixelLUTPtr = ^PixelLUTType; IntLineType = array[0..MaxLine] of integer; var line: LineType; i, j, value, LineSize, offset: LongInt; ScaleFactor: extended; hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer; PixelLUT: PixelLUTPtr; str1, str2: str255; err: integer; aLine: IntLineType; procedure reset; var DataSize, SliceOffset: LongInt; p: ptr; begin with info^ do begin if StackInfo <> nil then SliceOffset := ImageSize * 2 * (StackInfo^.CurrentSlice - 1) else SliceOffset := 0; err := SetFPos(f, fsFromStart, ImageDataOffset + SliceOffset); if DataH <> nil then begin if offset = -1 then begin hlock(DataH); DataSize := ImageSize * 2; err := fsread(f, DataSize, DataH^); end; offset := 0 end; end; end; procedure GetIntLine (var line: IntLineType); type atype = packed array[1..2] of char; var p: ptr; a: atype; c: char; i: integer; begin with info^ do begin if DataH <> nil then begin p := ptr(ord4(DataH^) + offset); BlockMove(p, @line, LineSize); offset := offset + LineSize; end else err := fsread(f, LineSize, @line); if LittleEndian then for i := 0 to LineSize div 2 - 1 do begin a := atype(line[i]); c := a[1]; a[1] := a[2]; a[2] := c; line[i] := integer(a) end; end; end; begin with info^ do begin PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType))); if PixelLUT = nil then begin if DataH <> nil then begin DisposHandle(DataH); DataH := nil end; PutMessage('Not enough memory to do 16 to 8-bit scaling.'); macro := false; exit(ScaleToEightBits); end; offset := -1; reset; LineSize := PixelsPerLine * 2; if (AbsoluteMin = 0) and (AbsoluteMax = 0) then begin AbsoluteMin := 999999; AbsoluteMax := -999999; for vloc := 0 to nlines - 1 do begin GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value > AbsoluteMax then AbsoluteMax := value; if value < AbsoluteMin then AbsoluteMin := value; end {for hloc:=} end;{for vloc := } if (CurrentMin = 0) and (CurrentMax = 0) then begin CurrentMin := AbsoluteMin; CurrentMax := AbsoluteMax; end; reset; end; str1 := concat('min=', long2str(CurrentMin), ' (', long2str(AbsoluteMin), ')', cr, 'max=', long2str(CurrentMax), ' (', long2str(AbsoluteMax), ')'); ScaleFactor := 253.0 / (CurrentMax - CurrentMin); RealToString(ScaleFactor, 1, 4, str2); ShowMessage(concat(str1, cr, 'scale factor= ', str2)); j := 0; for i := CurrentMin to CurrentMax do begin PixelLUT^[j] := round((i - CurrentMin) * ScaleFactor + 1); j := j + 1; end; for vloc := 0 to nlines - 1 do begin GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value < CurrentMin then value := CurrentMin; if value > CurrentMax then value := CurrentMax; line[hloc] := PixelLUT^[value - CurrentMin]; i := i + 1; end; PutLine(0, vloc, PixelsPerLine, line); end; if DensityCalibrated then begin fit := StraightLine; nCoefficients := 2; coefficient[2] := (CurrentMin - CurrentMax) / 253.0; coefficient[1] := CurrentMax - coefficient[2]; ZeroClip := false; UpdateTitleBar; end else DensityCalibrated := false; DisposPtr(ptr(PixelLUT)); if DataH <> nil then begin DisposHandle(DataH); DataH := nil end; end; {with} end; procedure RescaleToEightBits; var range: LongInt; err: OSErr; f: integer; begin with info^ do begin ShowWatch; KillRoi; DisableDensitySlice; err := fsopen(title, vref, f); if CheckIO(err) <> 0 then exit(RescaleToEightBits); range := CurrentMax - CurrentMin; if ColorStart > 0 then CurrentMax := CurrentMax - round((ColorStart / 255) * range) else CurrentMax := AbsoluteMax; if ColorEnd < 255 then CurrentMin := CurrentMin + round(((255 - ColorEnd) / 255) * range) else CurrentMin := AbsoluteMin; ScaleToEightBits(f); err := fsclose(f); InvertPic; UpdatePicWindow; ResetMap; if DensityCalibrated then GenerateValues; end; end; procedure Import16BitSlices (f: integer); var i, err: integer; h: handle; DataSize, nImages, MaxImages, FileSize: LongInt; begin with info^ do begin nImages := ImportCustomSlices; err := GetEof(f, FileSize); MaxImages := (FileSize - ImportCustomOffset) div (ImageSize * 2); if nImages > MaxImages then nImages := MaxImages; if nImages < 2 then exit(Import16BitSlices); ShowMessage(CmdPeriodToStop); StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(Import16BitSlices); end; {with} with info^, info^.StackInfo^ do begin nSlices := nImages; SliceSpacing := 0.0; LoopTime := 0.0; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := NewHandle(PixMapSize); if h = nil then begin nSlices := i - 1; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; if not ImportAutoScale then begin CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); if ((CurrentMax - CurrentMin) > 65536) or (CurrentMin > CurrentMax) then begin CurrentMin := 0; CurrentMin := 0; end; end; ScaleToEightBits(f); InvertPic; InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutMessage(concat('Not enough memory to open all ', long2str(nImages), ' slices in the stack.')); end; CurrentSlice := 1; SelectSlice(CurrentSlice); UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); end; end; function Import16BitFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; begin Import16BitFile := false; if ImportCustomWidth > MaxLine then exit(Import16BitFile); if not NewPicWindow(fname, ImportCustomWidth, ImportCustomHeight) then exit(Import16BitFile); ShowWatch; err := fsopen(fname, vNum, f); with info^ do begin PictureType := imported; ImageDataOffset := ImportCustomOffset; DataType := ImportCustomDepth; vref := vnum; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; LittleEndian := ImportSwapBytes; DensityCalibrated := ImportCalibrate; if not ImportAutoScale then begin CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); if ((CurrentMax - CurrentMin) > 65536) or (CurrentMin > CurrentMax) then begin CurrentMin := 0; CurrentMin := 0; end; end; DataH := GetBigHandle(PixMapSize * 2); ScaleToEightBits(f); if ImportCustomSlices > 1 then Import16BitSlices(f); err := fsclose(f); InvertPic; if PixMapSize > UndoBufSize then PutWarning; revertable := false; end; {with} Import16BitFile := true; end; procedure InitPictBuffer (howBig: LongInt); begin repeat PictBuffer := NewPtr(howBig); if PictBuffer = nil then howBig := howBig div 2; until PictBuffer <> nil; DisposPtr(PictBuffer); PictBuffer := NewPtr(howBig div 2); end; procedure FillPictBuffer; var count: LongInt; err: OSErr; begin count := GetPtrSize(PictBuffer); if not fitsInPictBuffer then begin err := FSRead(PictF, count, PictBuffer); if err <> NoErr then PictReadErr := true; end; bytesInPictBuffer := count; curPictBufPtr := PictBuffer; end; procedure GetPICTData (dataPtr: Ptr; byteCount: Integer); {Input picture spooler routine taken from Apple's PICTViewer example program.} var count: LongInt; anErr: OSErr; begin count := byteCount; repeat if bytesInPictBuffer >= count then begin BlockMove(curPictBufPtr, dataPtr, count); curPictBufPtr := Ptr(Ord4(curPictBufPtr) + count); bytesInPictBuffer := bytesInPictBuffer - count; count := 0; end else begin {Not enough in buffer} if bytesInPictBuffer > 0 then begin BlockMove(curPictBufPtr, dataPtr, bytesInPictBuffer); dataPtr := Ptr(Ord4(dataPtr) + bytesInPictBuffer); count := count - bytesInPictBuffer; end; FillPictBuffer; end; until count = 0; end; procedure BitInfo (var srcBits: PixMap; var srcRect, dstRect: rect; mode: integer; maskRgn: rgnHandle); var i, size: integer; begin if BitInfoCount = 0 then begin PictSrcRect := srcRect; if srcBits.rowBytes < 0 then with srcBits.pmTable^^ do begin{Make sure it is a PixMap.} size := ctSize; if size > 255 then size := 255; if size > 0 then begin BitInfoCount := BitInfoCount + 1; if not UseExistingLUT then with info^ do begin for i := 0 to size do cTable[i].rgb := ctTable[i].rgb; LutMode := ColorLut; SetupPseudocolor; end; end; end; {with} end; end; procedure GetLUTFromPict (thePict: PicHandle); {Refer to "Screen Dump FKEY for Color Picts", February 1988 MacTutor.} type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SavePort: GrafPtr; err: osErr; TempPort: CGrafPort; limbo: rect; xscale, yscale: extended; begin GetPort(SavePort); OpenCPort(@TempPort); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; tempProcs.getPicProc := @GetPICTData; PictSrcRect := thePict^^.picFrame; BitInfoCount := 0; TempPort.grafProcs := @tempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; limbo := thePict^^.picFrame; OffsetRect(limbo, 10000, 10000); if not PictReadErr then DrawPicture(thePict, limbo); CloseCPort(@TempPort); SetPort(SavePort); with info^, PictSrcRect do begin LoadLUT(cTable); xScale := (right - left) / PixelsPerLine; yScale := (bottom - top) / nLines; if (xScale > 1.0) and ((PixelsPerLine * xScale) <= MaxLine) and ((xScale - yScale) < 0.1) then begin PixelsPerLine := right - left; nLines := bottom - top; end; end; {with} end; function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean} var err: OSErr; i: integer; iptr: ptr; PictSize, HowBig, NextTiffIFD: LongInt; thePict: PicHandle; tPort: GrafPtr; tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; SaveInfo: InfoPtr; procedure Abort; begin if not reverting then begin DisposPtr(pointer(Info)); Info := SaveInfo; LoadLUT(info^.cTable); end; if thePict <> nil then DisposHandle(handle(thePict)); if PictF <> 0 then err := fsclose(PictF); exit(OpenPict); end; begin PictF := 0; thePict := nil; OpenPict := false; PictReadErr := false; ShowWatch; SaveInfo := Info; err := fsopen(fname, vNum, PictF); if CheckIO(err) <> 0 then Abort; if not Reverting then begin iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(PictF); exit(OpenPict) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); end; with Info^ do begin err := GetEof(PictF, PictSize); if CheckIO(err) <> 0 then Abort; PictSize := PictSize - 512; if PictSize <= 0 then Abort; WhatToOpen := OpenPICT2; if not OpenHeader(PictF, fname, vnum, NextTiffIFD) then Abort; thePict := PicHandle(NewHandle(SizeOf(Picture))); if thePict = nil then Abort; err := SetFPos(PictF, fsFromStart, 512); if CheckIO(err) <> 0 then Abort; howBig := SizeOf(Picture); err := FSRead(PictF, howBig, Pointer(thePict^)); if CheckIO(err) <> 0 then Abort; with thePict^^.PicFrame do begin nlines := bottom - top; PixelsPerLine := right - left; end; {....} err := GetEof(PictF, howBig); howBig := howBig - (512 + SizeOf(Picture)); InitPictBuffer(HowBig * 2); if GetPtrSize(PictBuffer) >= howBig then begin err := FSRead(PictF, howBig, PictBuffer); if CheckIO(err) <> NoErr then begin DisposHandle(handle(thePict)); DisposPtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; fitsInPictBuffer := true; end else fitsInPictBuffer := false; if (LutMode = ColorLut) or (LutMode = CustomGrayscale) or (iVersion = 0) then GetLUTFromPict(thePict); if not Reverting then begin PicBaseAddr := GetImageMemory(SaveInfo, PicBaseHandle); if PicBaseAddr = nil then begin DisposHandle(handle(thePict)); DisposPtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; MakeNewWindow(fname); end; if (PixMapSize > UndoBufSize) and (not Reverting) then begin PutWarning; ShowWatch; end; if isGrayScaleLUT then ResetGrayMap; GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); EraseRect(PicRect); SaveProcsPtr := pointer(osPort^.grafProcs); SetStdCProcs(tempProcs); tempProcs.getPicProc := @GetPICTData; osPort^.grafProcs := @TempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, PicRect); osPort^.grafProcs := pointer(SaveProcsPtr); DisposHandle(handle(thePict)); DisposPtr(PictBuffer); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetPort(tPort); vref := vnum; PictureType := PictFile; revertable := true; end; {with} err := fsclose(PictF); SetupUndo; if not PictReadErr then OpenPict := true; end; procedure GetCLUT (thePict: PicHandle); type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; err: osErr; begin with info^ do begin SetPort(GrafPtr(osPort)); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; BitInfoCount := 0; osPort^.grafProcs := @tempProcs; DrawPicture(thePict, thePict^^.picFrame); osPort^.grafProcs := pointer(SaveProcsPtr); LoadLUT(cTable); end; end; function OpenPICS (name: str255; fRefNum: integer): boolean; var RefNum, picID, hOffset, vOffset, nPICS, i: integer; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; procedure Abort; begin CloseResFile(RefNum); exit(OpenPICS); end; begin OpenPics := false; if MaxBlock < MinFree then begin PutMessage('Insufficient memory to open PICS file.'); exit(OpenPICS); end; ShowWatch; err := SetVol(nil, fRefNum); RefNum := OpenResFile(name); if RefNum = -1 then begin PutMessage('Unable to open PICS file.'); exit(OpenPICS); end; nPICS := Count1Resources('PICT'); if nPICS < 1 then begin PutMessage('No PICTs found.'); abort; end; PicH := GetPicture(128); if PicH = nil then Abort; FrameRect := PicH^^.PicFrame; with FrameRect do begin hOffset := left; vOffset := top; right := right - hOffset; bottom := bottom - vOffset; left := 0; top := 0; end; with FrameRect do if not NewPicWindow(name, right - left, bottom - top) then Abort; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then Abort; with StackInfo^ do begin SliceSpacing := 0.0; LoopTime := 0.0; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; if not UseExistingLUT then GetCLUT(picH); with info^, Info^.StackInfo^ do begin SetPort(GrafPtr(osPort)); pmBackColor(WhiteIndex); EraseRect(PicRect); DrawPicture(picH, PicRect); DisposHandle(handle(picH)); UpdatePicWindow; picID := 129; MemError := false; for i := 2 to nPICS do begin PicH := GetPicture(picID); if (PicH = nil) or (ResError <> NoErr) then Leave; h := GetBigHandle(PixMapSize); if h = nil then begin if PicH <> nil then DisposHandle(handle(picH)); MemError := true; Leave; end; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); FrameRect := PicH^^.PicFrame; with FrameRect do begin right := right - hOffset; bottom := bottom - vOffset; left := left - hOffset; top := top - vOffset; end; EraseRect(PicRect); if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposHandle(handle(picH)); UpdatePicWindow; UpdateTitleBar; Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; end; CloseResFile(RefNum); if MemError then PutMessage('Not enough memory to open all images in PICS file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); if not MemError and not Aborted then OpenPICS := true; end; {with} end; {$D-} procedure OpenAll (RefNum: integer); {Opens all appropriate files in a folder. Original version contributed by Ira Rampil.} var OpenedOK: boolean; index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNUm := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then exit(OpenAll); ftype := ioFlFndrInfo.fdType; end; if ftype = 'IPIC' then begin WhatToOpen := OpenImage; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PICT' then begin if not OpenPICT(name, RefNum, false) then exit(OpenAll) end else if ftype = 'TIFF' then begin WhatToOpen := OpenTiff; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PNTG' then if not OpenMacPaint(name, RefNum) then exit(OpenAll); end; {while} end; procedure UpdateFileIcons (reply: SFReply); {Changes the creator of all files in the current folder from 'IMAG'(files created by V1.40 and earlier) to 'Imag'.} var OpenedOK: boolean; RefNum, index: integer; name: Str255; ftype, fcreator: OSType; err: OSErr; PB: HParamBlockRec; TheInfo: FInfo; count: integer; begin RefNum := reply.vRefNum; index := 0; count := 0; ShowWatch; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then leave; ftype := ioFlFndrInfo.fdType; fcreator := ioFlFndrInfo.fdCreator; end; if (fCreator = 'IMAG') and ((ftype = 'IPIC') or (ftype = 'PICT') or (ftype = 'TIFF') or (ftype = 'ICOL')) then begin err := GetFInfo(name, RefNum, TheInfo); if err <> NoErr then leave; TheInfo.fdCreator := 'Imag'; err := SetFInfo(name, RefNum, TheInfo); if err <> NoErr then leave; err := FlushVol(nil, RefNum); count := count + 1; end; end; {while} if count = 0 then PutMessage('None of the files in the current folder use the old icons.') else PutMessage(concat('The creator type of ', long2str(count), ' files in the current folder was changed from ''IMAG'' to ''Imag''.')); end; function OpenDialogHook (item: integer; theDialog: DialogPtr): integer; const OpenAllID = 11; KeepLutID = 12; UpdateIconsID = 13; var i: integer; begin if (item = -1) and UseExistingLUT then SetDialogItem(theDialog, KeepLutID, 1); if item = OpenAllID then begin OpenAllFiles := not OpenAllFiles; SetDialogItem(theDialog, OpenAllID, ord(OpenAllFiles)); end; if item = KeepLutID then begin UseExistingLUT := not UseExistingLUT; SetDialogItem(theDialog, KeepLutID, ord(UseExistingLut)); end; if item = UpdateIconsID then begin UpdateIcons := not UpdateIcons; SetDialogItem(theDialog, UpdateIconsID, ord(UpdateIcons)); end; OpenDialogHook := item; end; function DoOpen (FileName: str255; RefNum: integer): boolean; const MyDialogID = 70; var where: Point; reply: SFReply; b: boolean; sfPtr: ^SFTypeList; TypeList: array[0..10] of OSType; FileType: OSType; OKToContinue: boolean; FinderInfo: FInfo; err: OSErr; begin KillOperation; DisableDensitySlice; OpenAllFiles := false; UseExistingLUT := false; UpdateIcons := false; OKToContinue := false; if FileName = '' then begin where.v := 50; where.h := 50; typeList[0] := 'IPIC'; typeList[1] := 'PICT'; typeList[2] := 'TIFF'; typeList[3] := 'ICOL'; {Color Tables} typeList[4] := 'PX05'; {PixelPaint LUT} typeList[5] := 'CLUT'; {Klutz LUT} typeList[6] := 'drwC'; {Canvas LUT} typeList[7] := 'PNTG'; {MacPaint} typeList[8] := 'PICS'; typeList[9] := 'Iout'; {Outlines} typeList[10] := 'TEXT'; sfPtr := @TypeList; SFPGetFile(Where, '', nil, 11, sfPtr^, @OpenDialogHook, reply, MyDialogID, nil); if reply.good then with reply do begin FileName := fname; FileType := ftype; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; OKToContinue := true; end; if reply.good and UpdateIcons then begin UpdateFileIcons(reply); exit(DoOpen); end; if reply.good and OpenAllFiles then begin OpenAll(RefNum); exit(DoOpen); end; end else begin err := GetFInfo(FileName, RefNum, FinderInfo); FileType := FinderInfo.fdType; OKToContinue := true; end; DoOpen := OKToContinue; if OKToContinue then begin if FileType = 'IPIC' then begin WhatToOpen := OpenImage; b := OpenFile(FileName, RefNum) end else if FileType = 'PICT' then begin b := OpenPICT(FileName, RefNum, false) end else if FileType = 'TIFF' then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else if FileType = 'ICOL' then OpenColorTable(FileName, RefNum) else if FileType = 'PX05' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'CLUT' then ImportPalette('CLUT', FileName, RefNum) else if FileType = 'drwC' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'PNTG' then b := OpenMacPaint(FileName, RefNum) else if FileType = 'PICS' then b := OpenPICS(FileName, RefNum) else if FileType = 'Iout' then OpenOutline(FileName, RefNum) else if FileType = 'TEXT' then b := OpenTextFile(FileName, RefNum) else begin WhatToOpen := OpenUnknown; b := OpenFile(FileName, RefNum) end; info^.ScaleToFitWindow := false; end; end; procedure ImportAllFiles (RefNum: integer); var OpenedOK: boolean; index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then exit(ImportAllFiles); ftype := ioFlFndrInfo.fdType; end; if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then begin if not Import16BitFile(name, RefNum) then exit(ImportAllFiles); end else begin if not OpenFile(name, RefNum) then exit(ImportAllFiles); end; if CommandPeriod then begin beep; exit(ImportAllFiles); end; end; {while} end; procedure EditImportParameters; const WidthID = 2; HeightID = 3; OffsetID = 4; SlicesID = 5; FixedID = 6; MinID = 7; MaxID = 8; var mylog: DialogPtr; item, fwidth: integer; begin mylog := GetNewDialog(110, nil, pointer(-1)); SetDNum(MyLog, WidthID, ImportCustomWidth); SelIText(MyLog, WidthID, 0, 32767); SetDNum(MyLog, HeightID, ImportCustomHeight); SetDNum(MyLog, SlicesID, ImportCustomSlices); SetDNum(MyLog, OffsetID, ImportCustomOffset); SetDialogItem(MyLog, FixedID, ord(not ImportAutoScale)); if WhatToImport = ImportText then fwidth := 2 else fwidth := 0; SetDReal(MyLog, MinID, ImportMin, fwidth); SetDReal(MyLog, MaxID, ImportMax, fwidth); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); if item = WidthID then begin ImportCustomWidth := GetDNum(MyLog, WidthID); if (ImportCustomWidth < 0) or (ImportCustomWidth > MaxPicSize) then begin ImportCustomWidth := 512; SetDNum(MyLog, WidthID, ImportCustomWidth); end; end; if item = HeightID then begin ImportCustomHeight := GetDNum(MyLog, HeightID); if ImportCustomHeight < 0 then begin ImportCustomHeight := 512; SetDNum(MyLog, HeightID, ImportCustomHeight); end; end; if item = SlicesID then begin ImportCustomSlices := GetDNum(MyLog, SlicesID); if ImportCustomSlices < 0 then begin ImportCustomSlices := 1; SetDNum(MyLog, SlicesID, ImportCustomSlices); end; end; if item = OffsetID then begin ImportCustomOffset := GetDNum(MyLog, OffsetID); if ImportCustomOffset < 0 then begin ImportCustomOffset := 0; SetDNum(MyLog, OffsetID, ImportCustomOffset); end; end; if item = FixedID then begin ImportAutoScale := not ImportAutoScale; SetDialogItem(mylog, FixedID, ord(not ImportAutoScale)); end; if item = MinID then begin ImportMin := GetDReal(MyLog, MinID); ImportAutoScale := false; SetDialogItem(MyLog, FixedID, 1); end; if item = MaxID then begin ImportMax := GetDReal(MyLog, MaxID); ImportAutoScale := false; SetDialogItem(MyLog, FixedID, 1); end; until item = ok; DisposDialog(mylog); end; function ImportDialogHook (item: integer; myLog: DialogPtr): integer; const TiffID = 11; McidID = 12; TextID = 13; LutID = 14; CustomID = 15; WidthAndHeightID = 16; OffsetID = 17; EightBitsID = 18; SixteenBitsUnsignedID = 19; SixteenBitsSignedID = 20; SwapBytesID = 21; ImportAllID = 22; EditID = 23; CalibrateID = 24; InvertID = 25; var i: integer; procedure SetRadioButtons1; var i: integer; begin SetDialogItem(mylog, TiffID, 0); SetDialogItem(mylog, McidID, 0); SetDialogItem(mylog, LutID, 0); SetDialogItem(mylog, TextID, 0); SetDialogItem(mylog, CustomID, 0); case WhatToImport of ImportTiff: SetDialogItem(mylog, TiffID, 1); ImportMcid: SetDialogItem(mylog, McidID, 1); ImportLUT: SetDialogItem(mylog, LutID, 1); ImportText: SetDialogItem(mylog, TextID, 1); ImportCustom: SetDialogItem(mylog, CustomID, 1); end; end; procedure SetRadioButtons2; var i: integer; begin SetDialogItem(mylog, EightBitsID, 0); SetDialogItem(mylog, SixteenBitsUnsignedID, 0); SetDialogItem(mylog, SixteenBitsSignedID, 0); case ImportCustomDepth of EightBits: SetDialogItem(mylog, EightBitsID, 1); SixteenBitsUnsigned: SetDialogItem(mylog, SixteenBitsUnsignedID, 1); SixteenBitsSigned: SetDialogItem(mylog, SixteenBitsSignedID, 1); end; end; procedure ShowParameters; var str1, str2, str3: str255; begin NumToString(ImportCustomWidth, str1); NumToString(ImportCustomHeight, str2); NumToString(ImportCustomOffset, str3); ParamText(str1, str2, str3, ''); end; begin if item = -1 then begin {Initialize} SetRadioButtons1; SetRadioButtons2; ShowParameters; SetDialogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); SetDialogItem(mylog, ImportAllID, ord(ImportAll)); SetDialogItem(mylog, InvertID, ord(ImportInvert)); SetDialogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= TiffID) and (item <= CustomID) then begin case item of TiffID: WhatToImport := ImportTiff; McidID: WhatToImport := ImportMCID; LutID: WhatToImport := ImportLUT; TextID: WhatToImport := ImportText; CustomID: WhatToImport := ImportCustom; end; SetRadioButtons1; end; if item = EditID then begin EditImportParameters; WhatToImport := ImportCustom; SetRadioButtons1; ShowParameters; SetDialogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= EightBitsID) and (item <= SixteenBitsSignedID) then begin case item of EightBitsID: ImportCustomDepth := EightBits; SixteenBitsUnsignedID: ImportCustomDepth := SixteenBitsUnsigned; SixteenBitsSignedID: ImportCustomDepth := SixteenBitsSigned; end; SetRadioButtons2; WhatToImport := ImportCustom; SetRadioButtons1; end; if item = SwapBytesID then begin ImportSwapBytes := not ImportSwapBytes; SetDialogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); WhatToImport := ImportCustom; SetRadioButtons1; end; if item = ImportAllID then begin ImportAll := not ImportAll; SetDialogItem(mylog, ImportAllID, ord(ImportAll)); end; if item = InvertID then begin ImportInvert := not ImportInvert; SetDialogItem(mylog, InvertID, ord(ImportInvert)); end; if item = CalibrateID then begin ImportCalibrate := not ImportCalibrate; SetDialogItem(mylog, CalibrateID, ord(ImportCalibrate)); WhatToImport := ImportCustom; SetRadioButtons1; end; ImportDialogHook := item; end; {$POP} function ImportFile (FileName: str255; RefNum: integer): boolean; const ImportDialogID = 90; var where: Point; typeList: SFTypeList; reply: SFReply; b, ImportingTIFF: boolean; begin ImportFile := true; DisableDensitySlice; if not macro then ImportAll := false; if FileName = '' then begin where.v := 50; where.h := 50; SFPGetFile(Where, '', nil, -1, typeList, @ImportDialogHook, reply, ImportDialogID, nil); if not reply.good then begin ImportFile := false; exit(ImportFile); end; with reply do begin FileName := fname; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; end; end; ImportingTIFF := WhatToImport = ImportTiff; if ImportingTIFF then if not GetTIFFParameters(FileName, RefNum) then exit(ImportFile); case WhatToImport of ImportMCID: WhatToOpen := OpenImported; ImportCustom: begin if (ImportCustomDepth <> EightBits) and (ImportCustomWidth > MaxLine) then begin PutMessage(concat('Maximum width of imported 16-bit images is ', long2str(MaxLine), '.')); exit(ImportFile); end; WhatToOpen := OpenCustom; end; ImportLUT: begin DoImportLut(FileName, RefNum); exit(ImportFile); end; ImportText: begin ImportFile := ImportTextFile(FileName, RefNum); exit(ImportFile); end; end; if ImportAll then ImportAllFiles(RefNum) else if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then b := Import16BitFile(FileName, RefNum) else b := OpenFile(FileName, RefNum); if ImportingTIFF then WhatToImport := ImportTiff; end; procedure RevertToSaved; var fname: str255; err, f: integer; ok: boolean; begin if OpPending then KillRoi; DisableDensitySlice; with Info^ do begin fname := title; SetPort(wptr); if PictureType = PICTFile then begin ok := OpenPICT(fname, vref, true); UpdatePicWindow; end else begin ShowWatch; err := fsopen(fname, vref, f); ok := true; if HeaderOffset <> -1 then ok := OpenImageHeader(f, fname, vref); if ok then begin err := SetFPos(f, fsFromStart, ImageDataOffset); err := fsread(f, ImageSize, PicBaseAddr); with info^ do if (PictureType = PDP11) or (PictureType = InvertedTIFF) then InvertPic; if odd(PixelsPerLine) then UnpackLines; UpdatePicWindow; end; err := fsclose(f); RoiShowing := false; end; OpPending := false; Changes := false; end; {with} end; procedure FindWhatToPrint; var kind: integer; WhichWindow: WindowPtr; begin WhatToPrint := NothingToPrint; WhichWindow := FrontWindow; if WhichWindow = nil then exit(FindWhatToPrint); kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and info^.RoiShowing and measuring then kind := valuesKind; case kind of PicKind: if info^.RoiShowing then WhatToPrint := PrintSelection else WhatToPRint := PrintImage; HistoKind: WhatToPrint := PrintHistogram; ProfilePlotKind, CalibrationPlotKind: WhatToPrint := PrintPlot; ValuesKind, ResultsKind: if mCount > 0 then WhatToPrint := PrintMeasurements; TextKind: WhatToPrint := PrintText; otherwise ; end; if (WhatToPrint = NothingToPRint) and (info <> NoInfo) then WhatToPrint := PrintImage; end; procedure UpdateFileMenu; var ShowItems, isSelection: boolean; i: integer; str, str2: str255; begin with info^ do begin ShowItems := Info <> NoInfo; isSelection := RoiShowing and (RoiType = RectRoi); if OptionKeyWasDown and (CurrentKind <> TextKind) then begin SetItem(FileMenuH, CloseItem, 'Close All…'); SetItem(FileMenuH, SaveItem, 'Save All'); SetMenuItem(FileMenuH, CloseItem, ShowItems); end else begin SetItem(FileMenuH, CloseItem, 'Close…'); if isSelection and (CurrentKind <> TextKind) and (PictureType <> TiffFile) and (PictureType <> PictFile) and (CurrentKind = PicKind) then SetItem(FileMenuH, SaveItem, 'Save Selection') else SetItem(FileMenuH, SaveItem, 'Save'); SetMenuItem(FileMenuH, CloseItem, ShowItems or (CurrentKind = TextKind) or (CurrentKind = ProfilePlotKind) or (CurrentKind = CalibrationPlotKind) or (CurrentKind = HistoKind)); end; case CurrentKind of ProfilePlotKind, CalibrationPlotKind: ExportAsWhat := asPlotValues; HistoKind: ExportAsWhat := asHistogramValues; ResultsKind: ExportAsWhat := asMeasurements; PicKind: begin if (SaveAsWhat <> asPICT) then SaveAsWhat := asTiff; if (ExportAsWhat > asText) then ExportAsWhat := asRaw; end; otherwise end; if isSelection and (SaveAsWhat <> AsPalette) and (CurrentKind <> ResultsKind) and (CurrentKind <> TextKind) then SetItem(FileMenuH, SaveAsItem, 'Save Selection As…') else SetItem(FileMenuH, SaveAsItem, 'Save As…'); if isSelection and (ExportAsWhat <= AsText) then SetItem(FileMenuH, ExportItem, 'Export Selection As…') else SetItem(FileMenuH, ExportItem, 'Export…'); for i := SaveItem to SaveAsItem do SetMenuItem(FileMenuH, i, ShowItems or (CurrentKind = TextKind)); SetMenuItem(FileMenuH, ExportItem, ShowItems and (CurrentKind <> TextKind)); if isSelection then str := 'Duplicate Selection' else str := 'Duplicate'; SetItem(FileMenuH, DuplicateItem, str); for i := DuplicateItem to GetInfoItem do SetMenuItem(FileMenuH, i, ShowItems and (CurrentKind <> TextKind)); if DataType <> EightBits then str := 'Rescale' else str := 'Revert to Saved'; SetItem(FileMenuH, RevertItem, str); SetMenuItem(FileMenuH, RevertItem, (Revertable or (DataType <> EightBits)) and (CurrentKind <> TextKind)); SetMenuItem(FileMenuH, PlugInExportItem, ShowItems); FindWhatToPrint; case WhatToPrint of NothingToPrint: str := ''; PrintImage: str := 'Image'; PrintSelection: str := 'Selection'; PrintPlot: str := 'Plot'; PrintHistogram: str := 'Histogram'; PrintMeasurements: str := 'Measurements'; PrintText: str := 'Text'; end; SetItem(FileMenuH, PrintItem, concat('Print ', str, '…')); SetMenuItem(FileMenuH, PrintItem, WhatToPrint <> NothingToPrint); end; {with info^} end; procedure SaveAll; var SaveInfo: InfoPtr; i: integer; begin SaveInfo := Info; SaveAsWhat := AsTiff; SaveAllState := SaveAllStage1; for i := 1 to nPics do begin Info := pointer(WindowPeek(PicWindow[i])^.RefCon); SaveAs('', 0); if CommandPeriod or (SaveAllState = NoSaveAll) then leave; end; Info := SaveInfo; SaveAllState := NoSaveAll; end; procedure SaveScreen; var err, RefNum: integer; TheInfo: FInfo; name: str255; ok, NewFile: boolean; SaveInfo: InfoPtr; SaveNoInfoRec: PicInfo; ShutterSound: handle; begin name := 'Screen'; err := GetVol(nil, RefNum); err := GetFInfo(name, RefNum, TheInfo); case err of NoErr: begin if TheInfo.fdType <> 'PICT' then begin TypeMismatch(name); exit(SaveScreen) end; NewFile := false; end; FNFerr: begin err := create(name, RefNum, 'Imag', 'PICT'); if CheckIO(err) <> 0 then exit(SaveScreen); NewFile := true; end; otherwise if CheckIO(err) <> 0 then exit(SaveScreen) end; ShutterSound := GetResource('snd ', 100); if ShutterSound <> nil then begin err := SndPlay(nil, ShutterSound, false); ReleaseResource(ShutterSound); end; SaveInfo := info; SaveNoInfoRec := NoInfoRec; with NoInfo^ do begin PixelsPerLine := ScreenWidth; nLines := ScreenHeight; osPort := cScreenPort; SetRect(PicRect, 0, 0, ScreenWidth, ScreenHeight); LutMode := info^.LutMode; cTable := info^.cTable; end; info := NoInfo; ok := SavePICTFile(name, RefNum, false, NewFile); NoInfoRec := SaveNoInfoRec; info := SaveInfo; if ok then PutMessage('The screen has been dumped to a PICT file named “Screen” in the same folder as Image.'); end; function SuggestedExportName: str255; var name: str255; begin name := info^.title; case ExportAsWhat of asRaw, asMCID, asText: begin if name = 'Camera' then name := 'Untitled'; if ExportAsWhat = AsText then SuggestedExportName := concat(name, '(Text)') else SuggestedExportName := name; end; AsLUT: SuggestedExportName := 'Palette'; asMeasurements: SuggestedExportName := concat(name, '(Measurements)'); AsPlotValues: SuggestedExportName := concat(name, '(Plot Values)'); asHistogramValues: SuggestedExportName := concat(name, '(Histogram)'); asCoordinates: SuggestedExportName := concat(name, '(Coordinates)'); end; end; function ExportHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; RawID = 9; xyCoordinatesID = 16; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDialogItem(theDialog, RawID + ord(ExportAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedExportName; if (item >= RawID) and (item <= xyCoordinatesID) then begin ExportAsWhat := ExportAsWhatType(item - RawID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedExportName); SelIText(theDialog, EditTextID, 0, 32767); end; for i := RawID to xyCoordinatesID do SetDialogItem(theDialog, i, 0); SetDialogItem(theDialog, item, 1); end; ExportHook := item; end; procedure Export (name: str255; RefNum: integer); const CustomDialogID = 100; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; SaveAsState: SaveAsWhatType; begin with info^ do begin if (name = '') or (RefNum = 0) then begin where.v := 50; where.h := 50; if name = '' then name := SuggestedExportName; SFPPutFile(Where, 'Save as?', name, @ExportHook, reply, CustomDialogID, nil); if not reply.good then begin macro := false; exit(Export); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; isSelection := RoiShowing and (RoiType = RectRoi); case ExportAsWhat of asRaw, asMCID: begin if ExportAsWhat = asMCID then InvertPic; SaveAsState := SaveAsWhat; if ExportAsWhat = AsRaw then SaveAsWhat := asRawData else SaveAsWhat := SaveAsMCID; if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); SaveAsWhat := SaveAsState; end; AsText: ExportAsText(name, RefNum); AsLUT: SaveLUT(name, RefNum); asMeasurements: if mCount > 0 then ExportMeasurements(name, RefNum) else PutMessage('Sorry, but no measurements are available to export.'); AsPlotValues: if PlotWindow <> nil then begin kind := WindowPeek(PlotWindow)^.WindowKind; case kind of ProfilePlotKind: ConvertPlotToText; CalibrationPlotKind: ConvertCalibrationCurveToText; otherwise TextBufSize := 0; end; SaveAsText(name, RefNum); end else beep; asHistogramValues: if HistoWindow <> nil then begin ConvertHistoToText; SaveAsText(name, RefNum); end else beep; asCoordinates: ExportCoordinates(name, RefNum); otherwise beep; end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; end.